(SETQ IBASE (ADD1 7)) 


(DEFPROP FORFNS 
 (NIL FOR *FOR %FOR DONEP FOO1 FOO2) 
VALUE)

(DEFPROP FOR 
 (LAMBDA (L) (*FOR (CDR L))) 
MACRO)

(DEFPROP *FOR 
 (LAMBDA(L)
  (PROG (LC WO UO VAR A)
	(SETQ VAR (CAR L))
	(SETQ L (CDR L))
   L    (COND ((NULL L) (RETURN (%FOR VAR LC WO A UO)))
	      ((NULL (CAR L)) (GO L2))
	      ((MEMQ (CAAR L) (QUOTE (IN ON STEP NOLOOP))) (SETQ LC (CAR L)))
	      ((MEMQ (CAAR L) (QUOTE (DO COLLECT SUM))) (SETQ A (CAR L)))
	      ((MEMQ (CAAR L) (QUOTE (WHILE UNTIL))) (SETQ WO (CAR L)))
	      ((MEMQ (CAAR L) (QUOTE (UNLESS IF))) (SETQ UO (CAR L)))
	      (T (SETQ A (LIST (QUOTE DO) (CAR L)))))
   L2   (SETQ L (CDR L))
	(GO L))) 
EXPR)

(DEFPROP %FOR 
 (LAMBDA(VAR LC WO A UO)
  (CONS (QUOTE PROG)
	(CONS (APPEND (COND ((EQ (CAR LC) (QUOTE NOLOOP)) NIL) (T (NCONS VAR)))
		      (COND ((EQ (CAR LC) (QUOTE IN)) (QUOTE (%C))))
		      (COND ((EQ (CAR A) (QUOTE SUM)) (QUOTE (%R)))
			    ((EQ (CAR A) (QUOTE COLLECT)) (QUOTE (%R %R1)))))
	      (SUBST VAR
		     (QUOTE %X)
		     (SUBST (COND ((EQ (CAR LC) (QUOTE IN)) (QUOTE %C)) (T (QUOTE %X)))
			    (QUOTE %C)
			    (APPEND (COND ((EQ (CAR A) (QUOTE SUM)) (QUOTE ((SETQ %R 0))))
					  ((EQ (CAR A) (QUOTE COLLECT))
					   (QUOTE ((SETQ %R (SETQ %R1 (NCONS NIL)))))))
				    (COND
				     ((NOT (EQ (CAR LC) (QUOTE NOLOOP)))
				      (NCONS (LIST (QUOTE SETQ) (QUOTE %C) (CADR LC)))))
				    (QUOTE (L1))
				    (NCONS
				     (LIST (QUOTE COND)
					   (LIST
					    (FOO1 (COND ((EQ (CAR LC) (QUOTE STEP))
							 (DONEP VAR (CADDR LC) (CADDDR LC)))
							((EQ (CAR LC) (QUOTE NOLOOP)) NIL)
							(T (QUOTE (NULL %C))))
						  (COND ((NULL WO) NIL)
							((EQ (CAR WO) (QUOTE WHILE))
							 (LIST (QUOTE NOT) (CADR WO)))
							(T (CADR WO))))
					    (LIST (QUOTE RETURN)
						  (COND ((EQ (CAR A) (QUOTE SUM)) (QUOTE %R))
							((EQ (CAR A) (QUOTE COLLECT)) (QUOTE (CDR %R))))))))
				    (COND ((EQ (CAR LC) (QUOTE IN)) (QUOTE ((SETQ %X (CAR %C))))))
				    (NCONS
				     (FOO2 UO
					   (SUBST (CADR A)
						  (QUOTE %FOO)
						  (COND
						   ((EQ (CAR A) (QUOTE SUM)) (QUOTE (SETQ %R (PLUS %R %FOO))))
						   ((EQ (CAR A) (QUOTE COLLECT))
						    (QUOTE (SETQ %R1 (CDR (RPLACD %R1 (NCONS %FOO))))))
						   (T (QUOTE %FOO))))))
				    (COND ((EQ (CAR LC) (QUOTE STEP))
					   (NCONS
					    (SUBST (CADDR LC) (QUOTE %FOO) (QUOTE (SETQ %C (PLUS %C %FOO))))))
					  ((EQ (CAR LC) (QUOTE NOLOOP)) NIL)
					  (T (QUOTE ((SETQ %C (CDR %C))))))
				    (QUOTE ((GO L1))))))))) 
EXPR)

(DEFPROP DONEP 
 (LAMBDA(V S U)
  (COND ((NULL U) T)
	((NUMBERP S) (LIST (COND ((MINUSP S) (QUOTE *LESS)) (T (QUOTE *GREAT))) V U))
	(T (LIST (QUOTE MINUSP) (LIST (QUOTE *TIMES) (LIST (QUOTE *DIF) U V) S))))) 
EXPR)

(DEFPROP FOO1 
 (LAMBDA (X Y) (COND ((AND X Y) (LIST (QUOTE OR) X Y)) (Y Y) (T X))) 
EXPR)

(DEFPROP FOO2 
 (LAMBDA(UO L)
  (COND (UO
	 (LIST (QUOTE COND)
	       (LIST (COND ((EQ (CAR UO) (QUOTE UNLESS)) (LIST (QUOTE NOT) (CADR UO))) (T (CADR UO))) L)))
	(T L))) 
EXPR)